home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / C / ERROR.C < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-24  |  9.2 KB  |  289 lines
  1. /* ERROR.C
  2.  ************************************************************************
  3.  *                                    *
  4.  *        PC Scheme/Geneva 4.00 Borland C code            *
  5.  *                                    *
  6.  * (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7.  * (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8.  *                                    *
  9.  *----------------------------------------------------------------------*
  10.  *                                    *
  11.  *        Basic Error Message Handling                *
  12.  *                                    *
  13.  *----------------------------------------------------------------------*
  14.  *                                    *
  15.  * Created by: John Jensen        Date: 1985            *
  16.  * Revision history:                            *
  17.  * - 5 Jun 86:    Set or Ref of Fluid variable which is not defined in    *
  18.  *        fluid environment is now non-restartable from error    *
  19.  *        processor or inspector. (rb)                *
  20.  * - 16 Feb 86:    errors return to Scheme toplevel rather than aborting    *
  21.  *        to DOS (tc)                        *
  22.  * - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  23.  *                                    *
  24.  *                    ``In nomine omnipotentii dei''    *
  25.  ************************************************************************/
  26.  
  27. #include    <ctype.h>
  28. #include    <conio.h>
  29. #include    <stdio.h>
  30. #include    <stdlib.h>
  31. #include    <stdarg.h>
  32. #include    <string.h>
  33. #include    "scheme.h"
  34.  
  35. /************************************************************************/
  36. /* Wrong Number of Arguments to a Closure                */
  37. /************************************************************************/
  38. #define NUM_ARGS 16        /* offset of operand count in a closure object */
  39. void    wrong_args(int args_passed, REGPTR closure)
  40. {
  41.     int        expected;    /* the number of arguments expected */
  42.     unsigned    page, disp;    /* page/displacement parts of closure pointer */
  43.     char        msg[100];
  44.  
  45.  
  46.     /* determine the number of arguments expected */
  47.     page = CORRPAGE(closure->page);
  48.     disp = closure->disp;
  49.     if( ptype[page] == CONTTYPE )
  50.         expected = 1;
  51.         expected = get_word(page, disp + NUM_ARGS);
  52.  
  53.     sprintf( msg, "Invalid argument count: Function expected %d%s argument(s)\n"
  54.         "but was called with %%d as follows:",
  55.         expected > 0 ? expected : ~expected,
  56.         expected > 0 ? "" : " or more");
  57.  
  58.     arg_err( closure, args_passed, msg );
  59. }
  60.  
  61. /************************************************************************/
  62. /* Local Support-- Cons up "call" expression, output message text       */
  63. /************************************************************************/
  64. void    arg_err( REGPTR ftn, int args_passed, char msg[] )
  65. {
  66.     int        i;
  67.     REGPTR        this_reg;
  68.     char        newmsg[100];
  69.  
  70.     sprintf( newmsg, msg, args_passed ); 
  71.  
  72.                     /* cons up the function and arguments into a list */
  73.     this_reg = regs + args_passed;    /* pointer to last argument register */
  74.     tmp_reg = nil_reg;
  75.     for (i = 0; i < args_passed; i++, this_reg--)
  76.         cons(&tmp_reg, this_reg, &tmp_reg);
  77.     cons(&tmp_reg, ftn, &tmp_reg);    /* put procedure object at front of list */
  78.  
  79.     set_error(1, newmsg, &tmp_reg);    /* set up the error message text and irritant */
  80. }
  81.  
  82. /************************************************************************/
  83. /* Error-- Attempted to call a non-procedural object            */
  84. /************************************************************************/
  85. void    not_procedural(REGPTR non_ftn_obj, int args_passed)
  86. {
  87.     arg_err( non_ftn_obj, args_passed,
  88. "Attempt to call a non-procedural object with %d argument(s) as follows:");
  89. }
  90.  
  91. /************************************************************************/
  92. /* Error-- Symbol Not Fluidly Bound                    */
  93. /************************************************************************/
  94. #pragma    argsused
  95. void    not_fluidly_bound(unsigned page, unsigned disp, REGPTR source)
  96. {
  97.     /* create pointer to symbol and set up error parameters */
  98.     tmp_reg.page = ADJPAGE(page);
  99.     tmp_reg.disp = disp;
  100.     set_numeric_error(1, SET_FLUID_ERROR, &tmp_reg);
  101. }
  102.  
  103. /************************************************************************/
  104. /* Error-- Symbol Not Globally Bound                    */
  105. /************************************************************************/
  106. #pragma    argsused
  107. void    not_globally_bound(unsigned page, unsigned disp, REGPTR source)
  108. {
  109.     /* create pointer to symbol and set up error parameters */
  110.     tmp_reg.page = ADJPAGE(page);
  111.     tmp_reg.disp = disp;
  112.     set_numeric_error(0, SET_GLOBAL_ERROR, &tmp_reg);
  113. }
  114.  
  115. /************************************************************************/
  116. /* Error-- Symbol Not Lexically Bound                    */
  117. /************************************************************************/
  118. void    not_lexically_bound(unsigned page, unsigned disp)
  119. {
  120.     /* create pointer to symbol and set up error parameters */
  121.     tmp_reg.page = ADJPAGE(page);
  122.     tmp_reg.disp = disp;
  123.     set_numeric_error(0, SET_LEXICAL_ERROR, &tmp_reg);
  124. }
  125.  
  126. /************************************************************************/
  127. /* Error-- Symbol Not Bound                        */
  128. /************************************************************************/
  129. #pragma    argsused
  130. void    sym_undefined(unsigned page, unsigned disp, REGPTR env, REGPTR dest)
  131. {
  132.     int             error_number;    /* numeric error code */
  133.     int             error_restart;    /* Can you resume from error?
  134.                      * 0=yes,1=no */
  135.  
  136.     error_restart = 0;    /* Default to resumable */
  137.     if (env == &gnv_reg)
  138.         error_number = REF_GLOBAL_ERROR;
  139.     else {
  140.         if (env == &fnv_reg) {
  141.             error_number = REF_FLUID_ERROR;
  142.             error_restart = 1;    /* Can't continue from fluid error */
  143.         } else
  144.             error_number = REF_LEXICAL_ERROR;
  145.     }
  146.  
  147.     /* create pointer to undefined symbol and set message parameters */
  148.     tmp_reg.page = ADJPAGE(page);
  149.     tmp_reg.disp = disp;
  150.     set_numeric_error(error_restart, error_number, &tmp_reg);
  151. }
  152.  
  153. /************************************************************************/
  154. /* malloc error                                */
  155. /************************************************************************/
  156. void    malloc_error(char *routine)
  157. {
  158.     zprintf("[VM INTERNAL ERROR] %s: malloc error\n", routine);
  159.     zprintf("Press any key to return to Scheme toplevel.\n");
  160.     GETCH();
  161.     force_reset();
  162.     exit(0xff);
  163. }
  164.  
  165. /************************************************************************/
  166. /* set error condition                            */
  167. /************************************************************************/
  168. void    set_error(int code, char *message, REGPTR irritant)
  169. {
  170.     /* bind error code to the symbol |*error-code*| */
  171.     c_push(&tmp_reg);
  172.     intern(&tm2_reg, "*ERROR-CODE*", 12);
  173.     tmp_reg.page = ADJPAGE(SPECFIX);
  174.     tmp_reg.disp = code;
  175.     sym_bind(&tm2_reg, &tmp_reg, &gnv_reg);
  176.  
  177.     /* bind error message text to the symbol |*error-message*| */
  178.     intern(&tm2_reg, "*ERROR-MESSAGE*", 15);
  179.     alloc_string(&tmp_reg, message);
  180.     sym_bind(&tm2_reg, &tmp_reg, &gnv_reg);
  181.  
  182.     /* bind irritant to the symbol |*irritant*| */
  183.     c_pop(&tmp_reg);
  184.     intern(&tm2_reg, "*IRRITANT*", 10);
  185.     sym_bind(&tm2_reg, irritant, &gnv_reg);
  186. }
  187.  
  188. /************************************************************************/
  189. /* set numeric error condition             */
  190. /************************************************************************/
  191. void    set_numeric_error(int code, int error_number, REGPTR irritant)
  192. {
  193.     REG    lcl_reg;
  194.  
  195.     lcl_reg.page = ADJPAGE( SPECFIX );
  196.     lcl_reg.disp = code;
  197.  
  198.     /* bind error code to the symbol |*ERROR-CODE*| */
  199.     intern(&tm2_reg, "*ERROR-CODE*", 12);
  200.     sym_bind(&tm2_reg, &lcl_reg, &gnv_reg);
  201.  
  202.     /* bind error message text to the symbol |*ERROR-MESSAGE*| */
  203.     intern(&tm2_reg, "*ERROR-MESSAGE*", 15);
  204.     lcl_reg.disp = error_number;
  205.     sym_bind(&tm2_reg, &lcl_reg, &gnv_reg);
  206.  
  207.     /* bind irritant to the symbol |*IRRITANT*| */
  208.     intern(&tm2_reg, "*IRRITANT*", 10);
  209.     sym_bind(&tm2_reg, irritant, &gnv_reg);
  210. }
  211.  
  212. /************************************************************************/
  213. /* Process Invalid Source Operand Condition                */
  214. /************************************************************************/
  215. void    set_src_error(char *op, int args, ...)
  216. {
  217.     int        i;
  218.     REGPTR        *reg_ptr;
  219.      va_list        argptr;
  220.  
  221.     tmp_reg = nil_reg;
  222.  
  223.     va_start(argptr, args);
  224.     reg_ptr = &va_arg(argptr, REGPTR);
  225.     
  226.     for (i = args-1; i >= 0; i--)
  227.         cons(&tmp_reg, reg_ptr[i], &tmp_reg);
  228.     intern(&tm2_reg, op, strlen(op));
  229.     cons(&tmp_reg, &tm2_reg, &tmp_reg);
  230.     set_numeric_error(1, INVALID_OPERAND_ERROR, &tmp_reg);
  231.  
  232.     va_end(argptr);
  233. }
  234.  
  235. /************************************************************************/
  236. /* ERRMSG(code)                                */
  237. /* This simply prints whatever error message is called            */
  238. /* for by CODE.                             */
  239. /************************************************************************/
  240. void    errmsg(int code)
  241. {
  242.     switch (code) {
  243.     case QUOTERR:
  244.         zprintf("Bad quote form\n");
  245.         break;
  246.     case DOTERR:
  247.         zprintf("Bad dot form\n");
  248.         break;
  249.     case RPARERR:
  250.         zprintf(") before (\n");
  251.         break;
  252.     case PORTERR:
  253.         zprintf("Wrong port direction\n");
  254.         break;
  255.     case FULLERR:
  256.         zprintf("Disk full\n");
  257.         break;
  258.     case HEAPERR:
  259.         zprintf("Heap space exhausted\n");
  260.         zprintf("Press any key to return to Scheme toplevel.\n");    /* rb */
  261.         GETCH();    /* rb */
  262.         force_reset();
  263.         break;
  264.     case OVERERR:
  265.         zprintf("Flonum overflow\n");
  266.         break;
  267.     case DIV0ERR:
  268.         zprintf("Divide by zero\n");
  269.         break;
  270.     case EOFERR:
  271.         /* Don't print a message for end-of-file */
  272.         break;
  273.     case SHARPERR:
  274.         zprintf("#-macro error\n");
  275.         break;
  276.     }
  277. }
  278.  
  279. void    checkstack()
  280. {
  281.     if (stkspc() < 64)
  282.     {
  283.         zprintf("\n[VM ERROR encountered!] PC stack overflow\n"
  284.             "Attempting to execute SCHEME-RESET [Returning to top level]\n");
  285.         force_reset();
  286.     }
  287. }
  288.  
  289.